perm filename MUS5TR.F4[STR,LCS] blob
sn#307344 filedate 1978-03-09 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00005 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C***** STANFORD-IRCAM MUSIC FORMAT TO MUSIC-5 FORMAT TRANSLATOR ******
C00012 00003 C**** LOAD THIS VERSION WITH MUS5.F4,MUS5IO.FAI,PLASUB.MAC[MUS,LCS] ******
C00023 00004 SUBROUTINE MSCAN(LL,W)
C00034 00005 SUBROUTINE MPACK(WDCNT, I,NM)
C00037 ENDMK
C⊗;
C***** STANFORD-IRCAM MUSIC FORMAT TO MUSIC-5 FORMAT TRANSLATOR ******
C LELAND SMITH, IRCAM, PARIS, JUNE 1977
C
C
C THESE SUBROUTINES CONVERT STANFORD MUSIC FORMAT TO MUSIC-5 FORMAT,
C ALLOWING 'NOT CARDS' TO CONTAIN THE LETTER NAMES OF NOTES, (C,D,E,F,
C G,A,B; S=SHARP,F=FLAT), PARAMETER NUMBERS DESIGNATED AS P1, P2,
C P3, ETC., FUNCTION NAMES AS F1, F2, ETC., AND ARITHMATIC EXPRESSIONS.
C
C ALSO A PARAMETER FIELD MAY CONTAIN THE FUNCTION STATEMENT 'POWER(N1,N2)'
C WHERE THE RESULT PUT INTO THAT PARAMETER LOCATION IS THE VALUE OF N1 TO
C THE POWER OF N2.
C
C ARITHMETIC EXPRESSIONS MAY CONTAIN THE OPERATORS + - * / .
C SPACES BEFORE OR AFTER THESE OPERATORS ARE IGNORED! HENCE IN ORDER TO
C PUT A NEGATIVE NUMBER INTO A PARAMETER THE MINUS SIGN MUST BE PRECEDED
C BY A COMMA. 100 - 440 WILL PRODUCE THE SINGLE VALUE -340, WHEREAS
C 100, - 440 PRODUCES TWO SEPARATE VALUES. A PARAMETER MAY BE SETUP BY
C REFERRING TO OTHER PARAMETERS. IF P3=440 AND P5=2 THEN THE EXPRESSION
C P3 * POWER(2,1/24) /P5 WILL PUT THE VALUE 452.89 INTO A PARAMETER FIELD.
C ALL OPERATIONS ARE DONE IN LEFT-TO-RIGHT ORDER (UNLIKE FORTRAN OR ALGOL
C WHICH ALWAYS DO DIVIDES AND MULTIPLIES FIRST.) THUS A STATEMENT AS
C 5+7/2 WILL GIVE THE ANSWER 6. HOWEVER PARENTHESES MAY BE USED. 5+(7/2)
C GIVES THE ANSWER 8.5 . PARENTHESES MAY NOT BE 'NESTED'.
C
C INSTRUMENT DEFINITIONS AND GEN FUNCTION INPUT ARE MADE IN THE
C TRADITIONAL MUSIC5 FORMAT AS DESCRIBED IN THE BOOK BY MATHEWS, ET AL.
C HOWEVER THIS PROGRAM AUTOMATICALLY ADDS 2 INTERNALLY TO ALL PARAMETER
C NUMBERS GIVEN WITHIN INSTRUMENTS. FROM THE USER'S POINT OF VIEW THIS
C IS NOT IMPORTANT. THE HIGHEST PARAMETER NUMBER AVAILABLE IN INSTRUMENT
C DEFINITIONS IS P33. THE HIGHEST PARAMETER NUMBER AVAILABLE FOR 'NOT'
C LINES IS P30, THE LIMIT SET IN THE 'SCORE' PROGRAM.
C (SEE SCORE.DOC[DOC,LCS] )
C
C THE UNIT GENERATORS AVAILABLE ARE 'OUT','OSC','AD2','RAN','ENV','STR',
C 'AD3','AD4','MLT','SET','RAH','END'. IN ADDITION 'SRT' (OR 'SAM') IS
C USED TO SET THE SAMPLING RATE. HOWEVER THIS VARIABLE MUST BE SET USING
C THE LEFT ARROW, IN THE STANFORD FORMAT. (E.G. SRT←12800;) THIS ALSO
C CAN BE SET IN THE NORMAL STANFORD MUSIC FORMAT. (SRATE←25600;) THE
C NUMBER OF CHANNELS MUST BE SET IN THE STANFORD MANNER, NCHNS←1; OR
C NCHNS←2;. ADDITIONAL UNIT GENERATORS MAY BE USED (IF ADDED TO MUSIC5)
C BY SETTING UP AN INITIALIZING LIST AS FOLLOWS.
C
C UNIT GENS;
C UNIT-NAME(3 LETTERS ONLY) SPECIAL CODE NUM;
C . . . . . .
C END;
C
C UP TO 20 UNIT GENERATORS MAY BE ADDED. IF ONE OF THE INNER LINES
C APPEARED AS FOLLOWS, GUK 122; THEN THE NUMBER 122 WILL BE PUT
C IN THE MUSIC5 P3 FIELD WHENEVER THIS UNIT NAME IS ENCOUNTERED.
C
C AFTER INSTRUMENT DEFINITIONS ARE ENTERED AND BEFORE THE 'PLAY;'
C STATEMENT, EACH INSTRUMENT NAME TO BE USED MUST APPEAR IN THE FOLLOWING
C KIND OF LIST.
C INSTRUMENTS;
C NAME1 n1, n2, FREQ Pn, Pn . . . DUR Pn, Pn . . .
C NAME2 n1, n2 . . . etc.
C etc. . . . .
C END;
C
C UP TO 27 INSTRUMENTS MAY BE LISTED. n1 WILL BE THE MUSIC5 INSTRUMENT
C NUMBER. SEVERAL NAMES MAY BE ASSOCIATED A SINGLE INSTRUMENT NUMBER.
C n2 IS THE HIGHEST PARAMETER NUMBER REQUIRED BY THE INSTRUMENT.
C
C 'FREQ' AND 'DUR' ARE USED TO DESIGNATE CERTAIN PARAMETERS FOR CONVERSION
C TO INCREMENT NUMBERS WHICH WILL BECOME FREQUENCY OR DURATION INPUTS TO
C OSCILATORS, ETC. !!NOTE!! THE HIGHEST PARAMETER NUMBER (n2) WILL ALWAYS
C BE CONVERTED AS THE DURATION OF P2 (THE NOTE DURATION).
C I.E. THE PARAMETER USED TO INDICATE THE DURATION OF A STANDARD ENVELOPE
C WILL ALWAYS BE CONSIDERED TO BE THE LAST REAL PARAMETER OF THE INSTRUMENT.
C THUS THE USER NEED NOT CONCERN HIMSELF WITH 2 SEPARATE PARAMETERS, ONE
C FOR NOTE DURATION AND ONE FOR THE INCREMENT VALUE OF AN ENVELOPE WHICH
C LASTS FOR A COMPLETE NOTE DURATION. THIS LAST PARAMETER WILL ALWAYS BE
C SET UP AUTOMATICALLY BASED ON THE VALUE IN P2 AND THE SAMPLING RATE.
C
C ASIDE FROM THE INSTRUMENT AND GEN DEFINITIONS THIS PROGRAM WILL OPERATE
C IN AN INTERACTIVE MODE MUCH AS THE STANFORD-IRCAM MUSIC PROGRAM, AS
C DESCRIBED IN USEMUS.DOC[DOC,LCS].
C
C THE MAJOR DIFFERENCES ARE AS FOLLOWS:
C AS EACH 'MUSIC' STATEMENT IS TRANSLATED THE MUSIC-5 FORMAT IS
C NORMALLY TYPED OUT. THIS TYPEOUT MAY BE SUPPRESSED BY TYPING
C THE SYMBOL '&'. RETYPING THIS SYMBOL WILL CAUSE THE TYPEOUT
C TO BEGIN AGAIN.
C
C AFTER YOU ARE IN 'TTY MODE' ( > ) YOU MAY RETURN TO 'INPUT?'
C BY TYPING THE SYMBOL '!'.
C
C IF THE SYMBOL '%' IS TYPED, A BINARY FILE OF ALL MUSIC5 FORMAT
C INFORMATION WILL BE WRITTEN UNDER THE NAME 'FOR21.DAT'. THIS
C FILE SHOULD BE READABLE BY PASS3 OF THE BASIC MUSIC5 PROGRAM.
C
C THE VARIABLE 'MAG' OF THE STANFORD MUSIC PROGRAM IS COMPUTED
C AUTOMATICALLY WHEN EVER THE STATEMENTS SRATE←N; SRT N; OR
C SAM N; APPEAR. THE NUMBER OF CHANNELS IS INITIALIZED AT 1.
C THIS CAN BE CHANGED WITH NCHNS←N; OR CHA N;. N CAN ONLY BE
C A ONE OR A TWO.
C
C THE 'PRINT' STATEMENT WILL ONLY RECOGNIZE STANFORD NAMES, SUCH
C AS 'NCHNS' AND 'SRATE'. PRINT CHA; WILL NOT WORK.
C
C TO SEE THE LIST OF INSTRUMENTS CURRENTLY IN THE PROGRAM GO TO
C TTY MODE ( > ) AND TYPE <ALT>I <RETURN>.
C
C THE SOUND FILE COMPUTED WILL ALWAYS HAVE THE NAME 'MUSIC.MSB' AND BE
C WRITTEN ON DSKM. THE FILE CONTAINS THE STANDARD HEADER REQUIRED BY
C 'PLAY', 'WAVES', ETC.
C
C ALL ROUTINES IN THIS PROGRAM ARE IN FORTRAN WITH THE EXCEPTION OF
C MUS5IO.FAI AND PLASUB.MAC[MUS,LCS]. MUS5IO HAS ROUTINES TO PACK THE
C SAMPLES THREE TO A WORD AND TO WRITE THEM ON THE DSK. PLASUB IS
C SIMPLY THE 'PLAY' PROGRAM SET UP AS A FORTRAN CALLABLE SUBROUTINE.
C
C**** LOAD THIS VERSION WITH MUS5.F4,MUS5IO.FAI,PLASUB.MAC[MUS,LCS] ******
C**** TYPE 'DO DOMUS5.' ***** THIS LOADS AND SAVES AS 'M' WITH DDT. *****
C**** LOAD THIS VERSION WITH MUS5.F4,MUS5IO.FAI,PLASUB.MAC[MUS,LCS] ******
C**** TYPE 'DO DOMUS5.' ***** THIS LOADS AND SAVES AS 'M' WITH DDT. *****
C*** 33 PARAMS SEEMS TO BE LIMIT IN THIS VERSION. (30 IN 'SCORE') *****
SUBROUTINE MUS5TR(IFIRST,LL,W)
DIMENSION RX(100),JX(100),W(1)
COMMON /TR/I(80),IX(50),NN(2),LX(12),KKK(2),INST(27),MX5(40)
1,INSNUM(27),FQDR(5/32,27),ISCL(21),IPARS(40),IFUN(30)
1 ,P(30),IWD(11),NPAR(27),JSEM,IPRNT,IPP
1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
1,ENDX,J /KNAM/KNAM,IPLAY
COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT,JWRT
INTEGER FQDR
DOUBLE PRECISION NM,IX,KK,II
EQUIVALENCE (NM,NN),(IBL,LX(1)),(K,KK,KKK),(IZR,RZR)
1 ,(LESS,LX(9)),(RX,IX,IXJ,JX),(INN,RNN),(RX2,RX(3)),
1(P2,P(2)),(RX3,RX(5)),(I3,I(3)),(ISEMI,LX(2))
1,(IBLA,LX(1)),(IAST,LX(3)),(ISRT,IWD(4))
1,(IAROW,LX(7)),(KPRNT,IWD(6))
DATA LX/' ',';', '*','/','-','+'
1,"575004020100,'=','<' ,',' ,'(', ')'/
1 ,KKK(2)/' '/, IDOT/'.'/, IEX/536870912/,IDEV/1/
1,ISCL/'CF','C','CS','DF','D','DS','EF','E','ES','FF','F','FS',
1 'GF','G','GS','AF','A','AS','BF','B','BS'/,MX/0/
1, IDUR/'DUR'/,FILNM/"556563514300/,JPRNT/-1/,JWRT/1/
DATA IPARS/'P1','P2','P3','P4','P5','P6','P7','P8','P9',
1 'P10','P11','P12','P13','P14','P15','P16','P17','P18',
1 'P19','P20','P21','P22','P23','P24','P25','P26','P27','P28',
1 'P29','P30',
1 'P31','P32','P33','P34','P35','P36','P37','P38','P39','P40'/
DATA RMAG/.0512/,INUM/0/,SRATE/10000./,RNCHN/1./
DATA IFUN/'F1','F2','F3','F4','F5','F6','F7',
1 'F8','F9','F10','F11','F12','F13','F14','F15','F16','F17',
1 'F18','F19','F20','F21','F22','F23','F24','F25','F26','F27'
1 ,'F28','F29','F30'/
1,IWD/'PLAY','FINIS','FINI','SRATE','NCHNS','PRINT',
1 'CHA','POWER','SRT','SAM','GEN'/,IALT/"765004020100/
C LX INCLUDES ALL THE DIVIDERS.
401 IF(IFIRST)404, 5,600
404 IGEN=-1
IPLAY=0
ENDX=0
JSEM=0
INS=-1
402 IDEV=1
TYPE 1
1 FORMAT(' INPUT? '$)
100 FORMAT(' >'$)
2 FORMAT(2A5)
ACCEPT 2,NN
IF(NN(1).NE.IBLA)GO TO 400
IDEV=5
GO TO 5
400 IF(NN(1).EQ.'&')GO TO 603
C!*** & IS PRNT-NOPRNT FLIPFLOP
IF(NN(1).EQ.'%')GO TO 604
C!*** % IS WRT-NOWRT FLIPFLOP
REREAD 4,I
C! % WRITES BINARY FILE.
DO 409 K=2,7
409 IF(I(K).EQ.IDOT)GO TO 410
NN(2)=NN(2)+28
C!*** ADDS A DOT
410 CALL IFILE(1,NM)
CC410 OPEN(UNIT=1,FILE=NM)
4 FORMAT(80A1)
5 IF(JSEM.AND.J.LT.MM)GO TO 305
IF(JSEM.NE.99)GO TO 502
IFIRST=IFIRST+10
RETURN
600 JSEM=0
IFIRST=IFIRST-10
INS=-1
502 IF(IDEV.NE.5)GO TO 601
IF(IGEN.NE.2)IGEN=-1
TYPE 100
601 READ(IDEV,4,END=404)I
IF(I(1).EQ.'!')GO TO 404
C!**** USE ! TO RETURN TO 'INPUT?'
IF(I(1).EQ.'%')GO TO 604
C!*** %=WRITES BINARY FILE FOR21.DAT
IF(I(1).NE.'&')GO TO 602
C!*** &=TYPE OUT MUS5 NUMBERS
603 JPRNT=-JPRNT
GO TO 401
604 JWRT=-JWRT
C!*** DEFAULT IS NO-WRITE BINARY
GO TO 401
602 IF(I(1).NE.IALT)GO TO 408
IF(I(2).NE.'I')GO TO 605
C!***<ALT>I(NSTRUMENT LIST;)
DO 606 K=1,INUM
JK=NPAR(K)-2
606 TYPE 607,INST(K),INSNUM(K),JK
GO TO 5
607 FORMAT(1XA5,' NUM=',I2,' PARAMS=',I2)
C!*** PRINTS INST INFO.
605 SBFILN=FILNM
CALL PLAY
C!**** GO PLAY SOMETHING
GO TO 5
408 DO 407 K=1,60
407 JX(K)=IBLA
DO 405 K=1,80
IF(I(K).EQ.LESS)GO TO 5
405 IF(I(K).NE.IBLA)GO TO 406
GO TO 5
406 MM=0
J=-1
IPRNT=0
JI=0
9 M=0
N=JI+1
6 JI=JI+1
K=I(JI)
DO 7 L=1,12
7 IF(K.EQ.LX(L))GO TO 8
M=M+1
GO TO 6
C!**** NO STRING CAN EXCEED 10 CHARS.
8 IF(K.EQ.LESS)GO TO 15
IF(M.EQ.0)GO TO 14
IF(M.GT.10)M=10
MM=MM+1
IF(MM.LE.50)GO TO 88
TYPE 888,(I(JJ),JJ=N,N+9)
STOP
888 FORMAT(' LINE TOO LONG -- ',10A1)
88 JJ=I(N)
IF(JJ)GO TO 16
C!***** JUMP IF 1ST CHAR. IS A LETTER.
Y=0
DOT=10.
DO 18 JK=N,N+M-1
JA=I(JK)
IF(JA.NE.IDOT)GO TO 17
DOT=.1
GO TO 18
17 X=(JA-'0')/IEX
C!**** CHANGE ASCII INTO NUMBER
IF(DOT.LT.1)GO TO 19
Y=Y*DOT+X
GO TO 18
19 Y=Y+X*DOT
DOT=DOT/10.
18 CONTINUE
RX(MM*2-1)=Y
RX(MM*2)=9999999.
GO TO 14
16 CALL MPACK(M,I(N),IX(MM))
IF(IXJ.NE.'INSTR')GO TO 14
INS=0
GO TO 5
14 IF(IXJ.NE.'COMME')GO TO 140
141 READ(1,4)I
IF(I3.NE.ISEMI)GO TO 141
C!***** EAT THE DIRECTORY
GO TO 5
144 MX=MX+1
MX5(MX)=IXJ
C!*** PUT IS NEW UNIT GEN. NAME
MX=MX+1
MX5(MX)=RX(3)
GO TO 5
140 IF(IXJ.NE.'UNIT')GO TO 143
INS=1
C!*** 'UNIT GENERATOR' IS RESERVED FOR NEW ONES.
GO TO 5
143 IF(K.EQ.IBL)GO TO 10
IF(L.EQ.8)K=IAROW
C!::: CHANGE = INTO ←
MM=MM+1
IX(MM)=KK
10 IF(I(JI+1).NE.IBL)GO TO 11
JI=JI+1
GO TO 10
11 IF(JI.LT.80)GO TO 9
C NOW WE HAVE ALL ITEMS IN IX ARRAY
15 MM=MM*2
IF(IXJ.NE.KPRNT)GO TO 142
INS=-1
C!***** FOR 'PRINT'
IPRNT=-1
142 J=-1
IF(INS.LT.0)GO TO 305
IF(INS.EQ.2)GO TO 305
26 IF(IXJ.NE.'END')GO TO 127
MM=0
INS=-1
C!***** NOW INITITIALIZATION COMPLETE
GO TO 5
127 IF(INS.EQ.1)GO TO 144
C!*** FOR 'UNIT GEN' ADDED
IF(INUM.EQ.0)GO TO 2127
DO 1127 K=1,INUM
C!** FOR POSSIBLE REDEFINITION OF INST.
1127 IF(IXJ.EQ.INST(K))GO TO 3127
C!*** IS INST ALREADY IN LIST?
2127 INUM=INUM+1
K=INUM
3127 INST(K)=IXJ
C!**** GET THE NAME OF AN INST.(5 LTRS ONLY)
INSNUM(K)=RX2
C!*** GET ITS NUMBER.
NPAR(K)=RX3+2
C!**** GET NUM OF PARAMS, ADD 3 FOR W ARRAY
K=7
28 LL=-1
IF(JX(K).NE.IDUR)GO TO 31
LL=-LL
C!*** NOW LOOK AT REST OF THE LINE
31 K=K+2
IF(K.GT.MM)GO TO 5
C!**** CHECK FOR END OF LINE
IF(RX(K+1).NE.9999999)GO TO 28
JA=RX(K)+2
IF(JA.LT.5)GO TO 31
C!***** IGNORE P1,P2 OF INPUT
FQDR(JA,INUM)=LL
C!**** 1=DUR, -1=FREQ, 0=ORDINARY NUM.
GO TO 31
50 IF(IGEN)308,309,309
309 LL=LL-1
IF(JSEM.LE.0.AND.IGEN.EQ.1)IGEN=-1
C!*** FOUND 'END'
GO TO 59
308 W(1)=1
IF(LL-1.GE.NPAR(IK))GO TO 56
54 IF(LL.LT.3)LL=3
DO 55 K=LL,NPAR(IK)-1
55 W(K)=P(K-2)
C!***** GET INFO ALREADY IN PARAMS
56 DO 57 K=3,LL-1
57 P(K-2)=W(K)
C!**** FILL UP P LIST AGAIN
X=W(3)
C!*** EXCHANGE W(2) AND W(3), ACTION TIME, INST #
W(3)=W(2)
W(2)=X
58 LL=NPAR(IK)
DO 52 K=5,LL-1
X=FQDR(K,IK)
IF(X.EQ.0)GO TO 52
IF(X)GO TO 53
W(K)=RMAG/W(K)
GO TO 52
53 W(K)=RMAG*W(K)
52 CONTINUE
IF(ENDX.LT.W(2)+P2)ENDX=W(2)+P2
W(LL)=RMAG/W(4)
C!********* PUT MAG/P2 AT END
59 IF(JPRNT.GE.0)GO TO 591
TYPE 590,KNAM
KNAM=IBLA
TYPE 51,LL,(W(K),K=1,LL)
591 IF(JWRT)WRITE(21)LL,(W(K),K=1,LL)
500 IFIRST=0
IF(IGEN.EQ.0)IGEN=-1
RETURN
590 FORMAT(1XA5,1X$)
306 IF(JPRNT)TYPE 1307,(W(K),K=1,LL-1)
IF(JPRNT.GT.0)TYPE 307,(W(K),K=1,LL-1)
IPRNT=0
C!** RESET NO-PRNT FLAG
JSEM=0
C!** RESET SEMICOLON FLAG
INS=-1
IF(J.GE.MM-1)GO TO 5
C!** GO READ ANOTHER LINE
305 CALL MSCAN(LL,W)
303 IF(IPRNT)GO TO 306
IF(J.LT.MM)JSEM=-1
C!**** STILL MORE CHARS TO COME.
IF(ENDX.GE.0)GO TO 302
ENDX=0
GO TO 500
302 IF(JSEM)50,5,5
51 FORMAT(I3,35F10.3)
307 FORMAT(F11.4,$)
1307 FORMAT(F11.4)
END
SUBROUTINE MSCAN(LL,W)
DIMENSION RX(100),JX(100),W(1),IB(20),M5(12),TONES(21)
COMMON /TR/I(80),IX(50),NN(2),LX(12),KKK(2),INST(27),MX5(40)
1,INSNUM(27),FQDR(5/32,27),ISCL(21),IPARS(40),IFUN(30)
1 ,P(30),IWD(11),NPAR(27),JSEM,IPRNT,IPP
1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
1,ENDX,J /KNAM/KNAM,IPLAY
COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT,JWRT
C OUT, OSC, AD2, RAN, ENV, STR, AD3, AD4, MLT, SET, RAH, GEN
INTEGER FQDR,RPR
DOUBLE PRECISION NM,IX,KK,II
EQUIVALENCE (NM,NN),(IBL,LX(1)),(K,KK,KKK),(IZR,RZR)
1 ,(LESS,LX(9)),(RX,IX,IX1,JX),(INN,RNN),(RX2,RX(3))
1 ,(P2,P(2)),(RX3,RX(5)),(I3,I(3)),(ISEMI,
1 LX(2)),(IBLA,LX(1)),(IAST,LX(3)),(ISRT,IWD(4)),(NCHNS,IWD(5))
1,(LPR,LX(11)),(RPR,LX(12)),(ICOM,LX(10)),(IPWR,IWD(8))
1,(LAROW,LX(7)),(JSRT,IWD(9))
DATA TONES/246.945,261.62,277.18,277.8,293.66,311.13,311.13,
1 329.63,349.23,329.63,349.23,369.99,369.99,
1 391.99,415.31,415.31,440.0,466.16,466.16,493.89,523.24/
DATA IB/'B1','B2','B3','B4','B5','B6','B7','B8','B9',
1 'B10','B11','B12','B13','B14','B15','B16','B17','B18',
1 'B19','B20'/
DATA M5/'OUT','OSC','AD2','RAN','ENV','STR','AD3',
1'AD4','MLT','SET','RAH','END'/
30 IF(JSEM.NE.0)GO TO 34
LL=1
INS=-1
34 J=J+2
IPP=0
C!FOR 'P3←333;' ETC.
IPOW=0
IOP=-1
IXJ=JX(J)
IF(IXJ.NE.ISEMI)GO TO 9
10 IF(IGEN.GT.100)W(3)=IGEN
15 JSEM=-1
RETURN
9 IF(J.GE.MM)GO TO 1001
IF(RX(J+1).EQ.9999999)GO TO 11
C!*** SKIP IF NUMBER
IF(IGEN.GT.0)GO TO 450
DO 32 K=1,11
C!***** LOOK FOR SPECIAL WORDS
32 IF(IWD(K).EQ.IXJ)
1 GO TO (3,13,13,304,303,302,303,4,505,505,422)K
IF(IXJ.NE.'INS')GO TO 402
KNAM=IXJ
W(1)=2
IGEN=2
GO TO 424
505 JK=4
C !**** FOR SRATE OR SRT
IF(K.NE.4)JK=2
JK=J+JK
GO TO 304
450 DO 400 K=1,12
400 IF(IXJ.EQ.M5(K))GO TO(425,425,425,425,425,425,425,425
1,425,425,425,411),K
DO 451 JK=1,40,2
C!*** FOR USER-ADDED UNIT GENS. (UP TO 20)
IF(MX5(JK).NE.IXJ)GO TO 451
W(3)=MX5(JK+1)
GO TO 426
451 CONTINUE
503 TYPE 504,IXJ
JSEM=0
J=MM
RETURN
504 FORMAT(' UNKNOWN SYMBOL ',A5)
411 LL=3
KNAM=IXJ
IGEN=1
C!*** =1 IS FLAG TO CHANGE IT TO -1
J=MM
INS=-1
GO TO 10
422 W(1)=3
C!***** GEN
KNAM=IXJ
IGEN=0
424 INS=-1
LL=2
GO TO 36
425 W(3)=K+100
426 KNAM=IXJ
436 LL=4
GO TO 36
3 J=J+2
C !**** FOUND 'PLAY;'
IF(JX(J).NE.ISEMI)CALL ERR(1)
IPLAY=-1
SBFILN='TEST'
CALL PUTFIL(SBFILN)
CALL FASTOU(I,128)
C THE HEADER (SUCH AS IT IS) USETO IN MAIN PROG.
JSEM=-1
IF(J.LT.MM)GO TO 34
JSEM=0
RETURN
4 JL=LL
JOP=IOP
J=J+2
IF(JX(J).NE.LPR)CALL ERR(2)
IPOW=-1
IOP=-1
GO TO 36
C!**FIND NUM UP TO THE COMMA
7 IF(IPOW.GT.0)GO TO 8
IPOW=1
GO TO 36
8 LL=LL-2
W(LL)=W(LL)**W(LL+1)
IPOW=0
IOP=JOP
C!** GET BACK FLAGS
GO TO 38
302 LL=1
IPRNT=-1
C!***** FOR 'PRINT' FEATURE
GO TO 36
304 SRATE=RX(J+4)
J=J+6
RMAG=512./SRATE
W(3)=4
W(4)=SRATE
351 W(1)=11
W(2)=0
IGEN=0
LL=5
GO TO 15
303 IF(IXJ.EQ.'CHA')J=J-2
RNCHN=RX(J+4)
C!**** FOR NCHNS←N;
J=J+6
CC IF(RX(JK+1).NE.9999999)JK=JK+2
C!*** SKIP A COMMA
CC IF(JX(JK+2).EQ.ISEMI)GO TO 352
C!*** FOR NCHNS←n;
352 W(3)=8
C!*** FOR NCHNS
W(4)=RNCHN-1
GO TO 351
35 IF(IPLAY.GE.0)CALL ERR(4)
W(2)=INSNUM(IK)
C!**** W IS P ARRAY IN MUSIC5
LL=3
C!**** W(2) AND W(3) WILL BE EXCHANGED LATER
KNAM=IXJ
36 J=J+2
IF(J.GT.MM)GO TO 1001
C!****** 50 = DONE
CC JK=J*2
IXJ=JX(J)
IF(IXJ.NE.ISEMI)GO TO 1
JSEM=-1
1000 IF(IPP.EQ.0)GO TO 10
P(IPP)=W(1)
LL=1
IPP=0
IF(J.LT.MM)GO TO 30
INS=-1
C!*** I HOPE THIS IS THE RIGHT PLACE FOR THIS.
1001 IF(IGEN.EQ.0.OR.JSEM.EQ.0)JSEM=1
IF(JSEM)JSEM=0
RETURN
1 IF(RX(J+1).NE.9999999)GO TO 2
11 IF(IOP)GO TO 40
IF(IOP.NE.5)GO TO 12
RX(J)=-RX(J)
C!*** IOP=5 MEANS MINUS WITH COMMA IN FRONT
W(LL)=RX(J)
LL=LL+1
GO TO 14
12 CALL ARITH(RX(J),W,LL)
14 IOP=-1
C!*** RESET OPERATOR FLAG
GO TO 36
C!*** USE PARENTH'S FOR COMPOSITE EXPRESSIONS!!!!
40 W(LL)=RX(J)
38 LL=LL+1
IF(IOP)GO TO 36
LL=LL-1
380 CALL ARITH(W(LL),W,LL)
GO TO 14
402 IF(JSEM.GT.0)GO TO 2
C!**** READING CONTINUATION LINE.
DO 33 IK=1,INUM
33 IF(IXJ.EQ.INST(IK))GO TO 35
INS=2
C! NEXT IS SOMETHING OUTSIDE OF INST. AND PARAMS.
2 IF(IGEN.GT.0)GO TO 427
DO 306 K=1,21
IF(IXJ.NE.ISCL(K))GO TO 306
W(LL)=TONES(K)
CC JK=K
CC CALL NOTES(JK,W(LL))
GO TO 38
306 CONTINUE
C!***** FINDS NOTE IN SCALE
427 DO 307 K=1,40
C!****** FIND A PARAM NUM.
IF(IXJ.NE.IPARS(K))GO TO 307
IF(INS.LE.0)GO TO 340
JK=J+2
IF(JX(JK).NE.LAROW)GO TO 340
IPP=K
LL=1
J=JK
GO TO 36
340 W(LL)=P(K)
C!***** FOUND Pn
IF(IPRNT)GO TO 38
IF(IGEN.GT.0)W(LL)=K+2.
C!*** PARAM NUMS ARE 2 LESS THAN IN BOOK.
GO TO 38
C!**** P4 IS CHANGED TO 6
307 CONTINUE
DO 344 K=1,30
IF(IXJ.NE.IFUN(K))GO TO 344
JL=K
IF(IGEN.GT.0)JL=-JL-100
C!*** FOR Fn IN INST DEFINITION
W(LL)=JL
GO TO 38
344 CONTINUE
IF(IGEN.LE.0)GO TO 341
DO 342 K=1,20
IF(IXJ.NE.IB(K))GO TO 342
W(LL)=-K
GO TO 38
342 CONTINUE
341 DO 39 K=3,6
IF(LX(K).NE.IXJ)GO TO 39
IOP=K-2
JK=JX(J-2)
IF(JK.EQ.ICOM)IOP=5
C!** COMMA DISABLES NEXT OPERATOR
IF(JK.EQ.LAROW)IOP=5
C!** ← DISABLES NEXT OPERATOR
IF(JK.EQ.LPR)IOP=5
C!** LFT PARENTH. DISABLES NEXT OPERATOR
GO TO 36
39 CONTINUE
308 IF(IXJ.EQ.LAROW)GO TO 36
C!*** PASS LEFT ARROW
IF(IXJ.EQ.IPWR)GO TO 4
IF(IXJ.EQ.RPR)GO TO 500
IF(IXJ.EQ.LPR)GO TO 500
IF(IXJ.NE.JSRT.AND.IXJ.NE.ISRT)GO TO 510
W(LL)=SRATE
335 LL=LL+1
GO TO 36
510 IF(IXJ.NE.NCHNS)GO TO 511
W(LL)=RNCHN
GO TO 335
511 IF(IXJ.NE.ICOM)GO TO 503
C!***** UNKNOWN CHAR.
500 IF(IPOW.NE.0)GO TO 7
IF(IXJ.NE.LPR)GO TO 501
JPOW=IPOW
IPOW=0
KOP=IOP
IOP=-1
JL=LL
C!**** SAVE VARIOUS POINTERS WHEN INSIDE PARENTHS.
GO TO 36
501 IF(IXJ.NE.RPR)GO TO 502
IPOW=JPOW
C!*** GET BACK STUFF
IOP=KOP
CC LL=JL+1 !**?????
IF(IOP)GO TO 36
LL=JL
GO TO 380
C!GO DO ARITHMETIC
502 IF(IPRNT)GO TO 36
C!**** FOUND COMMA IN PRINT STATEMENT.
5 IF(JX(J-2).NE.ICOM)GO TO 132
133 W(LL)=P(LL-2)
C!** ONLY CARES ABOUT 2 COMMAS IN A ROW
GO TO 335
132 IF(INS.GE.0)GO TO 36
IF(LL.EQ.3)GO TO 133
C!*** =3 MEANS COMMA FOR P1.
GO TO 36
13 LL=2
IPLAY=0
C!*** TURN OFF PLAY FLAG
W(1)=6
W(2)=ENDX+.5
C!***** ENDX IS P1+P2 OF THE LONGEST LASTING INST.
IF(JPRNT)TYPE 51,LL,W(1),W(2)
IF(JWRT.GE.0)GO TO 130
WRITE(21)LL,W(1),W(2)
END FILE 21
TYPE 131
130 J=MM
JSEM=99
C!*** WON'T READ LINE BEYOND 'FINISH;' ***************
ENDX=-1
51 FORMAT(I3,35F10.3)
131 FORMAT(' ***** FOR21.DAT WAS WRITTEN *****')
END
SUBROUTINE MPACK(WDCNT, I,NM)
EQUIVALENCE (NMM,NX)
DIMENSION I(1),M(10),NX(2)
DOUBLE PRECISION NM,NMM
INTEGER WDCNT
DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
DATA MM/"774000000000/
DO 1 K=1,10
M(K)=I(K)
1 IF(K.GT.WDCNT)M(K)=' '
JX=0
DO 2 J=1,2
NN=0
DO 10 K=5,1,-1
NN=NN .OR. (M(K+JX) .AND. MM)
IF (K-1) 20,20,17
17 IF (NN.GE.0)GO TO 13
NN = (( NN .AND. LL)/KK) .OR. JJ
GO TO 10
13 NN = NN / KK
10 CONTINUE
20 JX=5
2 NX(J)=NN
NM=NMM
END
SUBROUTINE ERR(N)
GO TO (1,2,3,4),N
1 TYPE 101
STOP
101 FORMAT(' MISSING SEMICOLON')
2 TYPE 102
STOP
102 FORMAT(' MISSING PARENTHESIS')
3 TYPE 103
STOP
103 FORMAT(' MISSING COMMA')
4 TYPE 104
104 FORMAT(' MISSING PLAY;')
STOP
END
SUBROUTINE ARITH(Y,W,LL)
DIMENSION W(1)
COMMON /AR/IOP
47 X=W(LL-1)
GO TO (41,42,43,44),IOP
41 X=X*Y
GO TO 45
42 X=X/Y
GO TO 45
43 X=X-Y
GO TO 45
44 X=X+Y
45 W(LL-1)=X
END